home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / ada / adaed-1.11 / adaed-1 / Adaed-1.11.0a / eval.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-02-07  |  46.8 KB  |  1,744 lines
  1. /*
  2.  * Copyright (C) 1985-1992  New York University
  3.  * 
  4.  * This file is part of the Ada/Ed-C system.  See the Ada/Ed README file for
  5.  * warranty (none) and distribution info and also the GNU General Public
  6.  * License for more details.
  7.  
  8.  */
  9.  
  10. #include "hdr.h"
  11. #include "vars.h"
  12. #include "attr.h"
  13. #include "arithprots.h"
  14. #include "setprots.h"
  15. #include "errmsgprots.h"
  16. #include "nodesprots.h"
  17. #include "machineprots.h"
  18. #include "sspansprots.h"
  19. #include "chapprots.h"
  20. #include "miscprots.h"
  21. #include "smiscprots.h"
  22. #include "evalprots.h"
  23.  
  24. /* Define DETAIL to break up some complicated expresssions into
  25.  * several statements to assist debugging using interactive debugger
  26.  */
  27. #define DETAIL
  28.  
  29. static Const const_val(Symbol);
  30. static Const eval_lit_map(Symbol);
  31. static Const const_fold(Node);
  32. static Const fold_unop(Node);
  33. static Const fold_op(Node);
  34. static Const fold_attr(Node);
  35. static Const fold_convert(Node);
  36. static Const eval_qual_range(Node, Symbol);
  37. static Const eval_real_type_attribute(Node);
  38. static Const check_overflow(Node, Const);
  39. static int  *fl_mantissa(int);
  40. static int *fl_emax(int);
  41. static void insert_and_prune(Node, Const);
  42. static Rational fx_max (Rational, Rational);
  43. static Const test_expr(int);
  44.  
  45. extern Const int_const(), real_const(), rat_const();
  46. extern ADA_MIN_INTEGER;
  47.  
  48. /* TBSL:provide proper link to ADA_SMALL_REAL*/
  49. #define ADA_SMALL_REAL 0.1
  50.  
  51. static Const const_val(Symbol obj)                                /*;const_val*/
  52. {
  53.     /* Return the constant value of the object if it has one;
  54.      * else return om.
  55.      * The constant value of a user-defined constant is derived from
  56.      * its SIGNATURE, when this is a constant value.
  57.      * The constant value of a literal is obtained from the literal map
  58.      * of its type.
  59.      */
  60.  
  61.     Tuple    sig;
  62.  
  63.     if (cdebug2 > 3) TO_ERRFILE("const_val");
  64.  
  65.     if (is_literal(obj)) return eval_lit_map(obj);
  66.  
  67.     sig = SIGNATURE(obj);
  68.     if( is_constant(obj) && is_scalar_type(TYPE_OF(obj))
  69.       && N_KIND((Node)sig) == as_ivalue) {
  70.         return (Const) N_VAL((Node)sig);
  71.         /* TBSL: could be static but not constant folded yet. */
  72.     }
  73.     else return const_new(CONST_OM);
  74. }
  75.  
  76. static Const eval_lit_map(Symbol obj)                    /*;eval_lit_map*/
  77. {
  78.     Symbol    typ;
  79.     Tuple    tup;
  80.     int    i;
  81.  
  82.     typ = TYPE_OF(obj);
  83.     tup = (Tuple) literal_map(typ);
  84.     for (i = 1; i <= tup_size(tup); i += 2) {
  85.         if (ORIG_NAME(obj) == (char *)0) continue;
  86.         if (streq(tup[i], ORIG_NAME(obj)))
  87.             return int_const((int)tup[i+1]);
  88.     }
  89.     return const_new(CONST_OM);
  90.     /*(return literal_map(TYPE_OF(obj))(original_name(obj));*/
  91. }
  92.  
  93. void eval_static(Node node)                                /*;eval_static*/
  94. {
  95.     /* Top level evaluation of static expressions and constant folding. The
  96.      * recursive procedure const_fold is invoked, and a top-level range 
  97.      * check on numeric results is performed.
  98.      */
  99.     /* If the node type is set to as_ivalue, the the N_VAL field will
  100.      * be a Const.
  101.      */
  102.     Const    result;
  103.  
  104.     result = const_fold(node);
  105.     if (result->const_kind != CONST_OM)
  106.         check_overflow(node, result);
  107. }
  108.  
  109. static Const const_fold(Node node)                            /*;const_fold*/
  110. {
  111.     /* This recursive procedure evaluates expressions, when static.
  112.      * If node is static, its actual value     is returned,  and the    node is
  113.      * modified to be an ivalue. Otherwise const_fold returns om, and node
  114.      * is    untouched. If the static  evaluation shows that the  expression
  115.      * would  raise an exception, a ['raise' exception] value  is produced
  116.      * and placed on the tree.
  117.      */
  118.  
  119.     Fortup ft1;
  120.     Node expn, index_list, index, discr_range;
  121.     Const    result;
  122.     Node    opn;
  123.     Node    n2, op_range;
  124.     Symbol    sym, op_type;
  125.  
  126.     /* */
  127. #define is_simple_value(t) ((t)->const_kind == CONST_INT \
  128.     || (t)->const_kind == CONST_UINT || (t)->const_kind == CONST_REAL)
  129.  
  130.     if (cdebug2 > 3) { }
  131.  
  132.     switch (N_KIND(node)) {
  133.     case(as_simple_name):
  134.         result = const_val(N_UNQ(node));
  135.         break;
  136.     case(as_ivalue):
  137.         result = (Const) N_VAL(node);
  138.         break;
  139.     case(as_int_literal):
  140.         /* TBSL: assuming int literal already converted check this Const*/
  141.         result = (Const) N_VAL(node);
  142.         break;
  143.     case(as_real_literal):
  144.         /*TBSL: assuming real literal already converted */
  145.         result = (Const) N_VAL(node);
  146.         break;
  147.     case(as_string_ivalue):
  148.         /* Will be static if required type has static low bound.*/
  149.         /*        indx := index_type(N_TYPE(node));
  150.          *        [-, lo_exp, -] := signature(indx);
  151.          * * Move this test to the expander, once format of aggregates is known.
  152.          *        if is_static_expr(lo_exp) then
  153.          *           lob := N_VAL(lo_exp);
  154.          *           av  := [v : [-, v] in comp_list];
  155.          *           result := check_null_aggregate(av, lob, indices, node);
  156.          *           result := ['array_ivalue', [v: [-, v] in comp_list], 
  157.          *                       lob, lob + #comp_list - 1];
  158.          *        else
  159.          */
  160.         result = const_new(CONST_OM);
  161.         /*        end if;    */
  162.         break;
  163.     case(as_character_literal):
  164.         result = const_new(CONST_STR);
  165.         break;
  166.     case(as_un_op):
  167.         result = fold_unop(node);
  168.         break;
  169.     case(as_in):
  170.         opn = N_AST1(node);
  171.         op_range = N_AST2(node);
  172.         result = eval_qual_range(opn, N_TYPE(op_range));
  173.         if (is_const_constraint_error(result))
  174.             result = test_expr(FALSE);
  175.         else if (!is_const_om(result))
  176.             result = test_expr(TRUE);
  177.         break;
  178.     case(as_notin):
  179.         opn = N_AST1(node);
  180.         n2 = N_AST2(node);
  181.         result = eval_qual_range(opn, N_TYPE(n2));
  182.         if (is_const_constraint_error(result))
  183.             result = test_expr(TRUE);
  184.         else if (!is_const_constraint_error(result))
  185.             result = test_expr(FALSE);
  186.         break;
  187.     case(as_op):
  188.         result = fold_op(node);
  189.         break;
  190.     case(as_call):
  191.         {
  192.             int i;
  193.             Tuple arg_list;
  194.             Const arg;
  195.  
  196.             opn = N_AST1(node);
  197.             result = const_new(CONST_OM);       /* in general not static */
  198.             arg_list = N_LIST(N_AST2(node));    /* but can fold actuals. */
  199.             for (i = 1; i <= tup_size(arg_list); i++)
  200.                 arg = const_fold((Node)arg_list[i]);
  201.             if (N_KIND(opn) == as_simple_name) {
  202.                 sym = ALIAS(N_UNQ(opn));
  203.                 if (sym != (Symbol)0 && is_literal(sym))
  204.                     /* replace call by actual value of literal */
  205.                     result = eval_lit_map(sym);
  206.             }
  207.         }
  208.         break;
  209.     case(as_parenthesis):
  210.         /* If the parenthesised expression is evaluable, return
  211.          * its value. Otherwise leave it parenthesised.
  212.          */
  213.         opn = N_AST1(node);
  214.         result = const_fold(opn);
  215.         break;
  216.     case(as_qual_range):
  217.         opn = N_AST1(node);
  218.         op_type = N_TYPE(node);
  219.         result = eval_qual_range(opn, op_type);
  220.         if (is_const_constraint_error(result)) {
  221.             create_raise(node, symbol_constraint_error);
  222.             result = const_new(CONST_OM);
  223.         }
  224.         break;
  225.     case(as_qual_index):
  226.         eval_static(N_AST1(node));
  227.         result = const_new(CONST_OM);
  228.         break;
  229.     case(as_attribute):
  230.     case(as_range_attribute):
  231.         /* use separate procedure for C */
  232.         result = fold_attr(node);
  233.         break;
  234.     case(as_qualify):
  235.         if (fold_context)
  236.             result = const_fold(N_AST2(node));
  237.         else
  238.             /* in the context of a conformance check, keep qualification.*/
  239.             result = const_new(CONST_OM);
  240.         break;
  241.         /* Type conversion:
  242.          * /TBSL/ These conversions are not properly checked!
  243.          */
  244.     case(as_convert):
  245.         /* use separate procedure for C */
  246.         result = fold_convert(node);
  247.         break;
  248.     case(as_array_aggregate):
  249.         /* This is treated in the expander.*/
  250.         result = const_new(CONST_OM);
  251.         break;
  252.     case(as_record_aggregate):
  253.         result = const_new(CONST_OM);
  254.         break;
  255.     case(as_selector): /*TBSL Case for discriminants needed */
  256.         expn = N_AST1(node);
  257.         eval_static(expn);
  258.         return const_new(CONST_OM);
  259.     case(as_slice):
  260.         expn = N_AST1(node);
  261.         discr_range = N_AST2(node);
  262.         eval_static(expn);
  263.         eval_static(discr_range);
  264.         return const_new(CONST_OM);
  265.     case(as_row):    /* Not folded for now.*/
  266.         /* p1 := check_const_val(op1);
  267.          * if is_value(op1) then
  268.          *    result := ['array_ivalue', [op1(2)], 1, 1];
  269.          * else
  270.          */
  271.         return const_new(CONST_OM);
  272.     case(as_index):
  273.         expn = N_AST1(node);
  274.         index_list = N_AST2(node);
  275.         eval_static(expn);
  276.  
  277.         FORTUP(index = (Node), N_LIST(index_list), ft1)
  278.             eval_static(index);
  279.         ENDFORTUP(ft1);
  280.         return const_new(CONST_OM);
  281.     default:
  282.         result = const_new(CONST_OM);
  283.     }
  284.     if (result->const_kind != CONST_OM)
  285.         insert_and_prune(node, result);
  286.  
  287.     return result;
  288. }
  289.  
  290. static Const fold_unop(Node node)                                /*;fold_unop*/
  291. {
  292.     Node    opn, oplist;
  293.     Const    result, op1;
  294.     int    op1_kind;
  295.     Symbol    sym;
  296.  
  297.     opn = N_AST1(node);
  298.     oplist = N_AST2(node);
  299.     op1 = const_fold((Node) (N_LIST(oplist))[1]);
  300.  
  301.     if (is_const_om(op1)) return op1;
  302.  
  303.     op1_kind = op1->const_kind;
  304.  
  305.     sym = N_UNQ(opn);
  306.     if (sym == symbol_addui) {
  307.         /*  the "+" can be ignored if it is used as a unary op */
  308.         result = op1;
  309.     }
  310.     else if (sym == symbol_addufl) {
  311.         result = op1;
  312.     }
  313.     else if (sym == symbol_addufx) {
  314.         result = op1;
  315.     }
  316.     else if (sym == symbol_subui ||
  317.         sym == symbol_subufl || sym == symbol_subufx) {
  318.         if (is_simple_value(op1)) {
  319.             if (sym == symbol_subui) {
  320.                 if (is_const_int(op1)) {
  321.                     if (INTV(op1) == ADA_MIN_INTEGER) {
  322.                         create_raise(node, symbol_constraint_error);
  323.                         result = const_new(CONST_OM);
  324.                     }
  325.                     else {
  326.                        result = int_const(-INTV(op1));
  327.                     }
  328.                 }
  329.                 else if (is_const_uint(op1))
  330.                     result = uint_const(int_umin(UINTV(op1)));
  331.                 else chaos("eval:subui bad type");
  332.             }
  333.             else if (sym == symbol_subufl) {
  334.                 const_check(op1, CONST_REAL);
  335.                 result = real_const(-REALV(op1));
  336.             }
  337.         }
  338.         else {
  339.             const_check(op1, CONST_RAT);
  340.             result= rat_const(rat_umin(RATV(op1)));
  341.         }
  342.     }
  343.     else if ( sym == symbol_not) {
  344.         if (is_simple_value (op1)) {
  345.             if (op1_kind == CONST_INT)
  346.                 result = int_const(1-INTV(op1)); /*bnot in setl */
  347.             else chaos("fold_unop: bad kind");
  348.         }
  349.         else {        /*TBSL*/
  350.             result = const_new(CONST_OM);
  351.         }
  352.     }
  353.     else if ( sym == symbol_absi ||
  354.         sym == symbol_absfl || sym == symbol_absfx) {
  355.  
  356.         if (is_simple_value(op1)) {
  357.             if (sym == symbol_absi) {
  358.                 if (op1_kind == CONST_INT) result = int_const(abs(INTV(op1)));
  359.                 else if (op1_kind == CONST_UINT)chaos("fold_unit absi in uint");
  360.                 else chaos("fold_unop: bad kind");
  361.             }
  362.             else if (sym == symbol_absfl) {
  363.                 result = real_const(fabs(REALV(op1)));
  364.             }
  365.         }
  366.         else {
  367.             result= rat_const(rat_abs(RATV(op1)));
  368.         }
  369.     }
  370.     return result;
  371. }
  372.  
  373. static Const fold_op(Node node)                                    /*;fold_op*/
  374. {
  375.     Node    opn, arg1, arg2, oplist;
  376.     Const    result, op1, op2, tryc;
  377.     Symbol    sym, op_name;
  378.     int    *uint;
  379.     int    rm;
  380.     Tuple    tup;
  381.     int    res, overflow;
  382.  
  383.     opn = N_AST1(node);
  384.     oplist = N_AST2(node);
  385.     tup = N_LIST(oplist);
  386.     arg1 = (Node) tup[1];
  387.     arg2 = (Node) tup[2];
  388.     op1 = const_fold(arg1);
  389.     op2 = const_fold(arg2);
  390.     op_name = N_UNQ(opn);
  391.  
  392.     /* If either operand raises and exception, so does the operation */
  393.     if (N_KIND(arg1) == as_raise) {
  394.         copy_attributes(arg1,  node);
  395.         return const_new(CONST_OM);
  396.     }
  397.     if (N_KIND(arg2) == as_raise 
  398.       && op_name != symbol_andthen && op_name != symbol_orelse) {
  399.         copy_attributes(arg2,  node);
  400.         return const_new(CONST_OM);
  401.     }
  402.  
  403.     if (is_const_om(op1) || (is_const_om(op2)
  404.       && (op_name != symbol_in || op_name != symbol_notin))) {
  405.         return const_new(CONST_OM);
  406.     }
  407.  
  408.     sym = op_name;
  409.  
  410.     if ( sym == symbol_addi || sym == symbol_addfl) {
  411.         if (sym == symbol_addi) {
  412.             res = word_add(INTV(op1), INTV(op2), &overflow);
  413.             if (overflow) {
  414.                 create_raise(node, symbol_constraint_error);
  415.                 result = const_new(CONST_OM);
  416.             }
  417.             else result = int_const(res);
  418.         }
  419.         else
  420.             result = real_const(REALV(op1) + REALV(op2));
  421.     }
  422.     else if ( sym == symbol_addfx) {
  423.         const_check(op1, CONST_RAT);
  424.         const_check(op2, CONST_RAT);
  425.         result= rat_const(rat_add(RATV(op1), RATV(op2)));
  426.     }
  427.     else if ( sym == symbol_subi) {
  428.         if (is_const_int(op1)) {
  429.             if (is_const_int(op2)) {
  430.                 res = word_sub(INTV(op1), INTV(op2), &overflow);
  431.                 if (overflow) {
  432.                     create_raise(node, symbol_constraint_error);
  433.                     result = const_new(CONST_OM);
  434.                 }
  435.                 else result = int_const(res);
  436.             }
  437.             else {
  438.                 chaos("fold_op: subi operand types");
  439.             }
  440.         }
  441.     }
  442.     else if (sym == symbol_subfl) {
  443.         result = real_const(REALV(op1) - REALV(op2));
  444.     }
  445.     else if ( sym == symbol_subfx) {
  446.         const_check(op1, CONST_RAT);
  447.         const_check(op2, CONST_RAT);
  448.         result= rat_const(rat_sub(RATV(op1), RATV(op2)));
  449.     }
  450.     else if ( sym == symbol_muli) {
  451. #ifdef TBSL
  452.         -- need to check for overflow and convert result back to int if not
  453.             -- note that low-level setl is missing calls to check_overflow that
  454.             -- are present in high-level and should be in low-level as well
  455.             result = int_mul(int_fri(op1), int_fri(op2));
  456. #endif
  457.         /* until overflow check in */
  458.         const_check(op1, CONST_INT);
  459.         const_check(op2, CONST_INT);
  460.         res = word_mul(INTV(op1), INTV(op2), &overflow);
  461.         if (overflow) {
  462.             create_raise(node, symbol_constraint_error);
  463.             result = const_new(CONST_OM);
  464.         }
  465.         else result = int_const(res);
  466.     }
  467.     else if ( sym == symbol_mulfl) {
  468.         const_check(op1, CONST_REAL);
  469.         const_check(op2, CONST_REAL);
  470.         if ((fabs(REALV(op1)) < ADA_SMALL_REAL)
  471.           || (fabs(REALV(op2)) < ADA_SMALL_REAL)) {
  472.             result = real_const(0.0);
  473.         }
  474.         else if (log(fabs(REALV(op1))) + 
  475.             log(fabs(REALV(op2))) > ADA_MAX_REAL) {
  476.             create_raise(node, symbol_constraint_error);
  477.             return const_new(CONST_OM);
  478.         }
  479.         else
  480.             result = real_const(REALV(op1) * REALV(op2));
  481.     }
  482.     else if ( sym == symbol_mulfx) {
  483.         const_check(op1, CONST_RAT);
  484.         const_check(op2, CONST_RAT);
  485.         result = rat_const(rat_mul(RATV(op1), RATV(op2)));
  486.     }
  487.     else if (sym == symbol_mulfxi || sym == symbol_mulfli) {
  488.         const_check(op1, CONST_RAT);
  489.         const_check(op2, CONST_RAT);
  490.         result = rat_const(rat_fri(int_mul(num(RATV(op1)), UINTV(op2)),
  491.           den(RATV(op1))));
  492.     }
  493.     else if (sym == symbol_mulifx) {
  494.         const_check(op1, CONST_UINT);
  495.         const_check(op2, CONST_RAT);
  496.         result = rat_const(rat_fri(int_mul(UINTV(op1), num(RATV(op2))),
  497.           den(RATV(op2))));
  498.     }
  499.     else if (sym == symbol_divi) {
  500.         if (INTV(op2)== 0) {
  501.             create_raise(node, symbol_constraint_error);
  502.             return const_new(CONST_OM);
  503.         }
  504.         result = int_const(INTV(op1) / INTV(op2));
  505.     }
  506.     else if (sym == symbol_divfl) {
  507.         const_check(op2, CONST_REAL);
  508.         if (fabs(REALV(op2)) < ADA_SMALL_REAL) {
  509.             create_raise(node, symbol_constraint_error);
  510.             return const_new(CONST_OM);
  511.         }
  512.         else if (fabs(REALV(op1)) < ADA_SMALL_REAL) {
  513.             const_check(op1, CONST_REAL);
  514.             result = real_const(0.0);
  515.         }
  516.         else if (log(fabs(REALV(op1))) -
  517.           log(fabs(REALV(op2))) >log(ADA_MAX_REAL)) {
  518.             create_raise(node, symbol_constraint_error);
  519.             return const_new(CONST_OM);
  520.         }
  521.         else {
  522.             result = real_const(REALV(op1)
  523.                 / REALV(op2));
  524.         }
  525.     }
  526.     else if (sym == symbol_divfx) {
  527.         /* TBSL: note that rnum(rat2) is in long integer format */
  528.         if (int_eqz(num(RATV(op2)))) {
  529.             create_raise(node, symbol_constraint_error);
  530.             return const_new(CONST_OM);
  531.         }
  532.         result = rat_const(rat_div(RATV(op1), RATV(op2)));
  533.     }
  534.     else if (sym == symbol_divfxi ||  sym == symbol_divfli) {
  535.         const_check(op1, CONST_RAT);
  536.         if (is_const_int(op2)) {
  537.             if (!INTV(op2)) {
  538.                 create_raise(node, symbol_constraint_error);
  539.                 return const_new(CONST_OM); }
  540.             result = rat_const(rat_fri(num(RATV(op1)), int_mul(den(RATV(op1)),
  541.               int_fri(INTV(op2))))); }
  542. /* Shouldn't be a rational
  543.         else if (is_const_rat(op2)) {
  544.             if (int_eqz(num(RATV(op2)))) {
  545.                 create_raise(node, symbol_constraint_error);
  546.                 return const_new(CONST_OM); }
  547.             result = rat_const(rat_div(RATV(op1), RATV(op2))); }
  548. */
  549.         else {
  550.             const_check(op2, CONST_UINT);
  551.             if (int_eqz(UINTV(op2))) {
  552.                 create_raise(node, symbol_constraint_error);
  553.                 return const_new(CONST_OM); }
  554.             result = rat_const(rat_fri(num(RATV(op1)), int_mul(den(RATV(op1)),
  555.               UINTV(op2))));
  556.         }
  557.     }
  558.     else if (sym == symbol_remi) {
  559.         if (INTV(op2) == 0) {
  560.             create_raise(node, symbol_constraint_error);
  561.             return const_new(CONST_OM);
  562.         }
  563.         result = int_const(INTV(op1) - (INTV(op1) / INTV(op2)) * INTV(op2));
  564.     }
  565.     else if (sym == symbol_modi) {
  566.         if (INTV(op2) == 0) {
  567.             create_raise(node, symbol_constraint_error);
  568.             return const_new(CONST_OM);
  569.         }
  570.         rm = INTV(op1) % INTV(op2);
  571.         if ((rm == 0) || (INTV(op2) > 0))
  572.             result = int_const(rm);
  573.         else
  574.             result = int_const(rm + INTV(op2));
  575.     }
  576.     else if (sym == symbol_expi) {
  577.         if (INTV(op2) < 0) {
  578.             create_raise(node, symbol_constraint_error);
  579.             return const_new(CONST_OM);
  580.         }
  581.         else {
  582.             if (is_const_int(op1))
  583.                 uint = int_fri(INTV(op1));
  584.             else
  585.                 chaos("expi: bad kind");
  586.             const_check(op2, CONST_INT);
  587.             result = int_const(int_toi(int_exp(uint, int_fri(INTV(op2)))));
  588.         }
  589.     }
  590.     else if (sym == symbol_expfl) {
  591.         const_check(op1, CONST_REAL);
  592.         const_check(op2, CONST_INT);
  593.         if ((fabs(REALV(op1)) < ADA_SMALL_REAL)
  594.           || ((abs(INTV(op2)) * log (fabs( REALV(op1)))) > log(ADA_MAX_REAL))) {
  595.             create_raise(node, symbol_constraint_error);
  596.             return const_new(CONST_OM);
  597.         }
  598.         return const_new(CONST_OM);
  599. #ifdef TBSL
  600.         -- need to find C form for **
  601.             pow(x, y) is x**y with x an y both double.
  602.             result = op1 ** op2;
  603. #endif
  604.     }
  605.     else if ((sym == symbol_cat) || (sym == symbol_cat_ca)
  606.       || (sym == symbol_cat_ac) || (sym == symbol_cat_cc)) {
  607.         /*  /TBSL/ Bounds may not be correct!*/
  608.         /*  [-, agg1, lb1, ub1] := op1;
  609.          *  [-, agg2, lb2, ub2] := op2;
  610.          *  agg := agg1 + agg2;
  611.          *  lb := lb1 min lb2;
  612.          */
  613.         result = const_new(CONST_OM);
  614.     }
  615.     else if (sym == symbol_and || sym == symbol_or || sym == symbol_xor) {
  616.         if (is_simple_value(op1)) {
  617.             if (N_UNQ(opn) == symbol_and) {
  618.                 if (is_const_int(op1))
  619.                     result = int_const(INTV(op1)&&INTV(op2));
  620.                 else
  621.                     chaos("fold_unop: bad kind");
  622.             }
  623.             else if (N_UNQ(opn) == symbol_or) {
  624.                 if (is_const_int(op1))
  625.                     result = int_const(INTV(op1)||INTV(op2));
  626.                 else
  627.                     chaos("fold_unop: or bad kind");
  628.             }
  629.             else if (N_UNQ(opn) == symbol_xor) {
  630.                 result = test_expr((INTV(op1))!= (INTV(op2)));
  631.             }
  632.             else {
  633.                 chaos("ERROR IN ES99");
  634.             }
  635.         }
  636.     }
  637.     else if (sym == symbol_andthen || sym == symbol_orelse) {
  638.         /* not static */
  639.         result = const_new(CONST_OM);
  640.     }
  641.     else if (sym == symbol_eq) {
  642. #ifdef TBSN
  643.         if (is_universal_real(op1) && is_universal_real(op2))
  644.             result = test_expr(rat_eql(op1, op2));
  645.         else
  646.             result = test_expr(op1 == op2);
  647. #endif
  648.         if (const_same_kind(op1, op2))
  649.             return test_expr(const_eq(op1, op2));
  650.         else return int_const(FALSE);
  651.     }
  652.     else if (sym == symbol_ne) {
  653. #ifdef TBSN
  654.         if (is_universal_real(op1) && is_universal_real(op2)) {
  655.             result = test_expr(rat_neq(op1, op2));
  656.         }
  657.         else {
  658.             /*TBSL: do we need two cases here */
  659.             if (is_const_int(op1))
  660.                 result = int_const(INTV(op1) != INTV(op2));
  661.             else if (is_const_real(op1))
  662.                 result = test_expr((REALV(op1) != REALV(op2)));
  663.             else
  664.                 chaos("error in ne case in const_fold");
  665.         }
  666. #endif
  667.         if (const_same_kind(op1, op2))
  668.             return test_expr(const_ne(op1, op2));
  669.         else return int_const(FALSE);
  670.     }
  671.     else if (sym == symbol_lt) {
  672.         if (is_simple_value(op1)) {
  673. #ifdef TBSN
  674.             if (is_const_int(op1)) {
  675.                 result = int_const(INTV(op1) < INTV(op2));
  676.             }
  677.             else {
  678.                 if (is_const_real(op1)) {
  679.                     result = real_const(REALV(op1)
  680.                         < REALV(op2));
  681.                 }
  682.                 else {
  683.                     chaos("fold_unop: lt bad kind ");
  684.                 }
  685.             }
  686. #endif
  687.             if (const_same_kind(op1, op2))
  688.                 return test_expr(const_lt(op1, op2));
  689.             else return int_const(FALSE);
  690.         }
  691.         /*TBSL     need array types */
  692.         else if (is_const_rat (op1) && is_const_rat (op2)) {
  693.             result = test_expr(rat_lss (RATV (op1), RATV (op2))); 
  694.         }
  695.         else {
  696.             result = const_new(CONST_OM); 
  697.         }
  698.     }
  699.     else if (sym == symbol_le) {
  700.         if (is_simple_value(op1)) {
  701. #ifdef TBSN
  702.             if (is_const_int(op1)) {
  703.                 result = int_const(INTV(op1) <= INTV(op2));
  704.             }
  705.             else if (is_const_real(op1)) {
  706.                 result = real_const(REALV(op1) <= REALV(op2));
  707.             }
  708.             else {
  709.                 chaos("fold_op: le bad kind");
  710.             }
  711. #endif
  712.             if (const_same_kind(op1, op2))
  713.                 return test_expr(const_le(op1, op2));
  714.             else return int_const(FALSE);
  715.         }
  716.         else {    /*TBSL need array types */
  717.             if (is_const_rat (op1) && is_const_rat (op2))
  718.                 result = test_expr(rat_leq (RATV (op1), RATV (op2))); 
  719.             else
  720.                 result = const_new(CONST_OM); 
  721.         }
  722.     }
  723.     else if (sym == symbol_gt) {
  724.         if (is_simple_value(op1)) {
  725. #ifdef TBSN
  726.             if (is_const_int(op1)) {
  727.                 result = int_const(INTV(op1) > INTV(op2));
  728.             }
  729.             else if (is_const_real(op1)) {
  730.                 result = real_const(REALV(op1)
  731.                     > REALV(op2));
  732.             }
  733.             else {
  734.                 chaos("fold_op: gt bad kind");
  735.             }
  736. #endif
  737.             if (const_same_kind(op1, op2))
  738.                 return test_expr(const_gt(op1, op2));
  739.             else return int_const(FALSE);
  740.         }
  741.         else {    /*TBSL need array types */
  742.             if (is_const_rat (op1) && is_const_rat (op2))
  743.                 result = test_expr(rat_gtr (RATV (op1), RATV (op2))); 
  744.             result = const_new(CONST_OM);
  745.         }
  746.     }
  747.     else if (sym == symbol_ge) {
  748.         if (is_simple_value(op1)) {
  749. #ifdef TBSN
  750.             if (is_const_int(op1))
  751.                 result = int_const(INTV(op1) >= INTV(op2));
  752.             else if (is_const_real(op1))
  753.                 result = real_const(REALV(op1) >= REALV(op2));
  754.             else
  755.                 chaos("fold op ge bad kind");
  756. #endif
  757.             if (const_same_kind(op1, op2))
  758.                 return test_expr(const_ge(op1, op2));
  759.             else
  760.                 return int_const(FALSE);
  761.         }
  762.         else {    /*TBSL need array types */
  763.             if (is_const_rat (op1) && is_const_rat (op2))
  764.                 result = test_expr(rat_geq (RATV (op1), RATV (op2))); 
  765.             result = const_new(CONST_OM);
  766.         }
  767.     }
  768.     else if (sym == symbol_in || sym == symbol_notin) {
  769.         specialize(arg1, N_TYPE(arg2));     /* ?? */
  770.         /* check whether this is correct, SETL is TYPE_OF, which is WRONG!!*/
  771.         if (N_KIND(arg2) != as_simple_name) {
  772.             result = const_new(CONST_OM); /* Could do better. */
  773.         }
  774.         else {
  775.             tryc = eval_qual_range(opn, N_UNQ(arg2));
  776.             if (is_const_constraint_error(tryc))
  777.                 result = test_expr(op_name == symbol_notin);
  778.             else if (!is_const_om(tryc))
  779.                 result= test_expr(op_name == symbol_in);
  780.         }
  781.  
  782.     }
  783.     else {
  784.         printf("bad operator symbol: %s\n", nature_str(NATURE(sym)));
  785.         chaos("fold_op: bad operator");
  786.     }
  787.     return result;
  788. }
  789.  
  790. static Const fold_attr(Node node)        /*;fold_attr*/
  791. {
  792.     Node    attr_node, typ_node, arg_node, f_node, l_node, l_n, h_n;
  793.     Symbol    typ1;
  794.     int        attrkind, is_t_n, rv, i, len, max;
  795.     Const    first, last, op1, result, lo, hi;
  796.     Tuple    tsig, sig, l;
  797.     Span    save_span;
  798.  
  799.     attr_node = N_AST1(node);
  800.     typ_node = N_AST2(node);
  801.     arg_node = N_AST3(node);
  802.  
  803.     /* Try to fold the prefix of the attribute*/
  804.     eval_static(typ_node);
  805.     /*attr = N_VAL(attr_node);  -- should be dead  3-13-86 ds */
  806.     attrkind = (int) attribute_kind(node);
  807.     if (N_KIND(typ_node) != as_simple_name) {
  808.         /*Not for attribute COUNT. beware!*/
  809.         typ1 = N_TYPE(typ_node);
  810.     }
  811.     else {
  812.         typ1 = N_UNQ(typ_node);
  813.     }
  814.     is_t_n = is_type_node(typ_node);
  815.     /* For array attributes, we establish whether it is being
  816.      * applied to an object or  to a type. The two operations
  817.      *  are distinguished in the interpreter by prefix O_ or T_
  818.      */
  819.     if ((attrkind == ATTR_T_FIRST || attrkind == ATTR_T_LAST
  820.       || attrkind == ATTR_T_RANGE || attrkind == ATTR_T_LENGTH )
  821.       && can_constrain(typ1) ) {
  822.  
  823. #ifdef ERRNUM
  824.             errmsgn(478, 479, attr_node);
  825. #else
  826.             errmsg( "attribute cannot be applied to unconstrained array type",
  827.               "3.6.2", attr_node);
  828. #endif
  829.     }
  830.     else if (attrkind == ATTR_T_SIZE || attrkind == ATTR_O_SIZE) {
  831.         node = size_attribute(node);
  832.         if (N_KIND(node) == as_ivalue) {
  833.             return (Const) N_VAL(node);
  834.         }
  835.         else {
  836.             return const_new(CONST_OM);
  837.         }
  838.     }
  839.     else if (attrkind == ATTR_BASE) {
  840.         save_span = get_left_span(node);
  841.         N_KIND(node) = as_simple_name;
  842.         /* clear attribute code so won't be taken as string*/
  843.         N_VAL(node) = (char *)0;
  844.         N_UNQ(node)     = base_type(typ1);
  845.         set_span(node, save_span);
  846.         return const_new(CONST_OM);
  847.     }
  848.  
  849.     if (!is_t_n)return const_new(CONST_OM);
  850.     /* This was needed in the high level, to prevent extra
  851.      * folding in non-static cases. It may be superfluous here
  852.      */
  853.     /* Attributes that are functions take the base type */
  854.     if (attrkind == ATTR_BASE || attrkind == ATTR_POS || attrkind == ATTR_PRED
  855.       ||attrkind == ATTR_SUCC || attrkind == ATTR_VAL
  856.       || attrkind == ATTR_VALUE) {
  857.         N_UNQ(typ_node) = base_type(typ1);
  858.     }
  859.     if (arg_node != OPT_NODE) {
  860.         op1 = const_fold(arg_node);
  861.         if (is_const_om(op1))return const_new(CONST_OM);
  862.     }
  863.     /* They are evaluable statically only if the subtype typ1
  864.      * itself is static.
  865.      */
  866.     if (is_type(typ1) && is_static_subtype(typ1)
  867.       || is_task_type(TYPE_OF(typ1))
  868.       || attrkind == ATTR_T_CONSTRAINED || attrkind == ATTR_O_CONSTRAINED) {
  869.         ;    /* try to evaluate */
  870.     }
  871.     else {
  872.         return const_new(CONST_OM); /* not static (RM 4.9 (8)*/
  873.     }
  874.     if (is_generic_type(typ1))    return const_new(CONST_OM);
  875.  
  876.     if (is_static_subtype(typ1)) {
  877.         tsig = SIGNATURE(typ1);
  878.         f_node = (Node) tsig[2];
  879.         l_node = (Node) tsig[3];
  880.         first = const_fold(f_node);
  881.         last = const_fold(l_node);
  882.     }
  883.  
  884.     /* Attributes of SCALAR types or ARRAY types: */
  885.  
  886.     if (attrkind == ATTR_O_FIRST || attrkind == ATTR_T_FIRST)
  887.         result = first;
  888.     else if (attrkind == ATTR_O_LAST || attrkind == ATTR_T_LAST)
  889.         result = last;
  890.     else if ( attrkind == ATTR_O_LENGTH || attrkind == ATTR_T_LENGTH
  891.       || attrkind == ATTR_O_RANGE || attrkind == ATTR_T_RANGE)
  892.         result = const_new(CONST_OM);
  893.     /* Attributes of DISCRETE types: */
  894.     else if (attrkind == ATTR_IMAGE) {
  895.         Symbol btyp1;
  896.         char *image;
  897.         Tuple tup;
  898.         int tsize;
  899.  
  900.         btyp1 = root_type(typ1);
  901.  
  902.         image = emalloct(10, "fold-attr");
  903.         if (btyp1 == symbol_integer) {
  904.             const_check(op1, CONST_INT);
  905.             if (INTV(op1) >= 0) sprintf(image, " %d", INTV(op1));
  906.             else sprintf(image, "%d", INTV(op1));
  907.         }
  908.         else {
  909.             /* image := 
  910.              *   if exists [nam, v] in literal_map(btyp1) | op1 = v
  911.              *       then nam else '' end;
  912.              */
  913.             image = "";
  914.             tup = (Tuple) literal_map(btyp1);
  915.             tsize = tup_size(tup);
  916.             for (i = 1; i <= tsize; i += 2) {
  917.                 const_check(op1, CONST_INT);
  918.                 if ((int)tup[i+1] == INTV(op1)) {
  919.                     image = strjoin(tup[i], "");
  920.                     break;
  921.                 }
  922.             }
  923.         }
  924.         N_KIND(node) = as_string_ivalue;
  925.         /* N_VAL(node)     = [abs c : c in image]; */
  926.         tsize = strlen(image);
  927.         tup = tup_new(tsize);
  928.         for (i = 1; i <= tsize; i++)
  929.             tup[i] = (char *) image[i-1];
  930.  
  931.         if (N_AST1_DEFINED(N_KIND(node))) N_AST1(node) = (Node) 0;
  932.         if (N_AST2_DEFINED(N_KIND(node))) N_AST2(node) = (Node) 0;
  933.         if (N_AST3_DEFINED(N_KIND(node))) N_AST3(node) = (Node) 0;
  934.         if (N_AST4_DEFINED(N_KIND(node))) N_AST4(node) = (Node) 0;
  935.         N_VAL(node) = (char *) tup;
  936.         result = const_new(CONST_OM);
  937.     }
  938.     else if (attrkind == ATTR_VALUE) {
  939.         chaos("value attrobute (eval.c)");
  940.     }
  941.     else if (attrkind == ATTR_POS) {
  942.         const_check(op1, CONST_INT);
  943.         result = uint_const(int_fri(INTV(op1)));    /*$ES10*/
  944.         /* result = int_const(int_fri(op1)); */          /*$ES10*/
  945.     }
  946.     else if (attrkind == ATTR_VAL || attrkind == ATTR_PRED
  947.       || attrkind == ATTR_SUCC) {
  948.         const_check(op1, CONST_INT);
  949.         rv = INTV(op1);
  950.         sig = SIGNATURE(base_type(typ1));
  951.         if (sig != (Tuple)0) {
  952.             l_n = (Node) sig[2];
  953.             h_n = (Node) sig[3];
  954.         }
  955.         else {
  956.             l_n = (Node) 0;
  957.             h_n = (Node) 0;
  958.         }
  959.         lo = const_fold(l_n);
  960.         hi = const_fold(h_n);
  961.         if (is_const_om(lo) || is_const_om(hi)) {
  962.             return const_new(CONST_OM);
  963.         }
  964.         if (attrkind == ATTR_PRED) {
  965.             const_check(lo, CONST_INT);
  966.             if (rv > INTV(lo)) rv -= 1;
  967.             else {
  968.                 create_raise(node, symbol_constraint_error);
  969.                 return const_new(CONST_OM);
  970.             }
  971.         }
  972.         else if (attrkind == ATTR_SUCC) {
  973.             const_check(hi, CONST_INT);
  974.             if (rv < INTV(hi)) rv += 1;
  975.             else {
  976.                 create_raise(node, symbol_constraint_error);
  977.                 return const_new(CONST_OM);
  978.             }
  979.         }
  980.         else if (attrkind == ATTR_VAL) {
  981.             const_check(lo, CONST_INT);
  982.             const_check(hi, CONST_INT);
  983.             if (rv < INTV(lo) || rv > INTV(hi)) {
  984.                 create_raise(node, symbol_constraint_error);
  985.                 return const_new(CONST_OM);
  986.             }
  987.         }
  988.         result = int_const(rv);
  989.     }
  990.     else if (attrkind == ATTR_WIDTH) {
  991.         int first_val, last_val, max_val;
  992.  
  993.         if (root_type(typ1) == symbol_integer) {
  994.             if (is_const_om(first) || is_const_om(last))
  995.                 chaos("eval WIDTH: unexpected const_kind");
  996.             const_check(first, CONST_INT);
  997.             const_check(last, CONST_INT);
  998.             /* In the case of a null range the Width is defined as 0.
  999.              * Otherwise it is defined as the maximum IMAGE length for
  1000.              * all values of the subtype.
  1001.              */
  1002.             if (INTV(first) > INTV(last))
  1003.                 result = uint_const(int_fri(0));
  1004.             else {
  1005.                 char *val_str = emalloct(10, "fold-attr-1");
  1006.                 first_val = abs(INTV(first));
  1007.                 last_val  = abs(INTV(last));
  1008.                 max_val = (first_val > last_val ? first_val : last_val);
  1009.                 sprintf(val_str, " %d", max_val);
  1010.                 result = uint_const(int_fri(strlen(val_str)));
  1011.                 efreet(val_str, "eval-fold-rat");
  1012.             }
  1013.         }
  1014.         else {
  1015.             /*   Must find longest name in enumeration subtype.  */
  1016.             int v;
  1017.             l = (Tuple) literal_map(root_type(typ1));
  1018.             max = 0;
  1019.             first_val = abs(INTV(first));    /* bounds of subtype */
  1020.             last_val  = abs(INTV(last));
  1021.             for (i = 1; i <= tup_size(l); i += 2) {
  1022.                 len = strlen(l[i]);
  1023.                 v = (int)l[i+1];
  1024.                 if (len > max && v >= first_val && v <= last_val)
  1025.                     max = len;
  1026.             }
  1027.             result = uint_const(int_fri(max));
  1028.         }
  1029.     }
  1030.  
  1031.     /* Miscellaneous attributes. */
  1032.  
  1033.     /* The following  attributes are  of type universal integer.
  1034.      * The current system ignores them, and passes them to the expander. 
  1035.      */
  1036.  
  1037.     else if (attrkind == ATTR_POSITION || attrkind == ATTR_FIRST_BIT
  1038.       || attrkind == ATTR_LAST_BIT || attrkind == ATTR_STORAGE_SIZE) {
  1039.         result = const_new(CONST_OM);
  1040.     }
  1041.     else if (attrkind == ATTR_O_CONSTRAINED || attrkind == ATTR_T_CONSTRAINED) {
  1042.         /* Attribute is true on constants and on -in- parameters */
  1043.         if ((typ1 != (Symbol) 0) &&
  1044.             NATURE(typ1) == na_constant || NATURE(typ1) == na_in) {
  1045.             result = int_const(1);
  1046.         }
  1047.         else if (!is_generic_type(typ1)) {
  1048.             /* it is false for private  types with discriminants.  */
  1049.             result = int_const( !(is_record(typ1) && has_discriminants(typ1)
  1050.               && NATURE(typ1) != na_subtype));
  1051.         }
  1052.         else {        /* run-time check */
  1053.             result = const_new(CONST_OM);
  1054.         }
  1055.     }
  1056.     else if (attrkind == ATTR_ADDRESS || attrkind == ATTR_TERMINATED 
  1057.       || attrkind == ATTR_CALLABLE) {
  1058.         result = const_new(CONST_OM);
  1059.     }
  1060.     else {
  1061.         /* Attributes of FIXED and FLOATing point types:*/
  1062.         result = eval_real_type_attribute(node);
  1063.     }
  1064.     return result;
  1065. }
  1066.  
  1067. static Const fold_convert(Node node)                        /*;fold_convert*/
  1068. {
  1069.     Node    typ2_node, opd_node;
  1070.     Symbol    typ1, typ2; /* type2 is target type */
  1071.     Const    opd, result;
  1072.  
  1073.     typ2_node = N_AST1(node);
  1074.     opd_node = N_AST2(node);
  1075.     typ1 = root_type(N_TYPE(opd_node));
  1076.     typ2 = root_type(N_UNQ(typ2_node));
  1077.     opd = const_fold(opd_node);
  1078.     if (is_const_om(opd)) {
  1079.         return const_new(CONST_OM);
  1080.     }
  1081.     if (typ1 == symbol_integer) {
  1082.         if (typ2 == symbol_integer) {
  1083.             result = opd;
  1084.         }
  1085.         else if (typ2 == symbol_float) {
  1086.             const_check(opd, CONST_INT);
  1087.             result = real_const((float)INTV(opd));
  1088.         }
  1089.         else if (typ2 == symbol_universal_integer)    {
  1090.             const_check(opd, CONST_INT);
  1091.             result    = uint_const(int_fri(INTV(opd)));
  1092.         }
  1093.         else if (typ2 == symbol_universal_real
  1094.           || typ2 == symbol_universal_fixed || typ2 == symbol_dfixed) {
  1095.             if (is_const_int(opd)) {
  1096.                 result = rat_const(rat_fri(int_fri(INTV(opd)), int_fri(1)));
  1097.             }
  1098.             else if (is_const_uint(opd)) {
  1099.                 result = rat_const(rat_fri(UINTV(opd), int_fri(1)));
  1100.             }
  1101.             else
  1102.                 chaos("const wrong type (eval.c)");
  1103.         }
  1104.         else
  1105.             result = const_new(CONST_OM);
  1106.     }
  1107.     else if (typ1 == symbol_float) {
  1108.         if (typ2 == symbol_integer || typ2 == symbol_universal_integer) {
  1109.             Rational z;
  1110.             int *x, *y;
  1111.             const_check(opd, CONST_REAL);
  1112.             z = rat_frr((double)(REALV(opd) + 0.5));
  1113.             x = num(z);
  1114.             y = den(z);
  1115.             result = uint_const(int_quo(x, y));
  1116.         }
  1117.         else if (typ2 == symbol_float) {
  1118.             result = opd;
  1119.         }
  1120.         else if (typ2 == symbol_dfixed || typ2 == symbol_universal_real
  1121.           || typ2 == symbol_universal_fixed) {
  1122.             result = rat_const(rat_frr((double)REALV(opd)));
  1123.         }
  1124.         else
  1125.             result = const_new(CONST_OM);
  1126.     }
  1127.     else if (typ1 == symbol_universal_integer) {
  1128.         if (typ2 == symbol_integer)
  1129. /*
  1130.             result = opd;
  1131. */
  1132.             result = int_const(int_toi(UINTV(opd)));
  1133.         else if (typ2 == symbol_float) {
  1134.             /* result = [opd, 1]; */
  1135.             /*    result = real_const((float) UINTV(opd)); */
  1136.             /*result = rat_const(rat_new(UINTV(opd), int_fri(1))); */
  1137.             result = const_new (CONST_OM);
  1138.         }
  1139.         else if (typ2 == symbol_universal_integer) {
  1140.             result = opd;
  1141.         }
  1142.         else if ( typ2 == symbol_universal_real ||
  1143.             typ2 == symbol_universal_fixed ||
  1144.             typ2 == symbol_dfixed) {
  1145.             result = rat_const(rat_fri(UINTV(opd), int_fri(1)));
  1146.         }
  1147.         else
  1148.             result = const_new(CONST_OM);
  1149.     }
  1150.     else if (typ1 == symbol_universal_real || typ1 == symbol_universal_fixed
  1151.       || typ1 == symbol_dfixed) {
  1152.  
  1153.         if (typ2 == symbol_float) {
  1154.             result = real_const (rat_tor (RATV (opd), ADA_REAL_DIGITS));
  1155.             if (arith_overflow) {
  1156.                 arith_overflow = FALSE;
  1157.                 create_raise (node, symbol_constraint_error);
  1158.                 result = const_new (CONST_OM);
  1159.             }
  1160.         }
  1161.         else if (typ2 == symbol_universal_real
  1162.           || typ2 == symbol_universal_fixed || typ2 == symbol_dfixed) {
  1163.             result = opd;
  1164.         }
  1165.         else if (typ2 == symbol_integer) {
  1166.             const_check(opd, CONST_RAT);
  1167.             result = int_const(rat_toi(RATV(opd)));
  1168.         }
  1169.         else
  1170.             result = const_new(CONST_OM);
  1171.     }
  1172.     else 
  1173.         result = const_new(CONST_OM);
  1174.  
  1175.     return result;
  1176. }
  1177.  
  1178. static Const eval_qual_range(Node op1, Symbol op_type)        /*;eval_qual_range*/
  1179. {
  1180.     /* This has been separated from the main body of const_fold because
  1181.      * it is used for two differents operators: 'qual_range' proper,
  1182.      * and 'in' and 'notin'
  1183.      *
  1184.      * If the expression is not static it return the former expression expn.
  1185.      * If the expression evaluates to a ['raise', 'CONSTRAINT_ERROR'] because
  1186.      * op1 is not in the range op2, it returns the string 'contraint_error'
  1187.      * without emitting any warning; this is left to the caller
  1188.      * responsibility.
  1189.      */
  1190.     Node    lo, hi;
  1191.     Const    op1_val, lo_val, hi_val;
  1192.     int        c_error;
  1193.     Tuple    numcon;
  1194.     Rational    rop1_val;
  1195.  
  1196.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : eval_qual_range");
  1197.  
  1198.     op1_val = const_fold(op1);
  1199.     if (op1_val->const_kind == CONST_OM)
  1200.         return const_new(CONST_OM);
  1201.  
  1202.     /* May just be a type name. */
  1203.     if (is_scalar_type(op_type)) {
  1204.         numcon = SIGNATURE(op_type);
  1205.         if (numcon != (Tuple)0) {
  1206.             lo = (Node) numcon[2];
  1207.             hi = (Node) numcon[3];
  1208.         }
  1209.         else {
  1210.             lo = (Node) 0;
  1211.             hi = (Node) 0;
  1212.         }
  1213.     }
  1214.     else
  1215.         return const_new(CONST_OM);
  1216.  
  1217.     /* If the argument is universal, convert it to
  1218.      * standard representation. A qual_range indicates
  1219.      * a constrained type, i.e. non-universal.
  1220.      */
  1221.  
  1222.     if (is_universal_integer(op1_val)) {
  1223.         const_check(op1_val, CONST_UINT);
  1224.         op1_val = int_const(int_toi(UINTV(op1_val)));
  1225.         if (arith_overflow) {
  1226.             arith_overflow = 0;
  1227.             return const_new(CONST_CONSTRAINT_ERROR);
  1228.         }
  1229.     }
  1230.     else if (is_universal_real(op1_val)
  1231.       && (!is_fixed_type(root_type(op_type)))) {
  1232.         const_check(op1_val, CONST_RAT);
  1233.         op1_val = real_const(rat_tor(RATV(op1_val), ADA_REAL_DIGITS));
  1234.         if (arith_overflow) {
  1235.             arith_overflow = FALSE;
  1236.             return const_new(CONST_CONSTRAINT_ERROR);
  1237.         }
  1238.     }
  1239.     if (N_KIND(lo) != as_ivalue || N_KIND(hi) != as_ivalue) {
  1240.         return const_new(CONST_OM);
  1241.     }
  1242.     else {
  1243.         lo_val = (Const) N_VAL(lo);
  1244.         hi_val = (Const) N_VAL(hi);
  1245.     }
  1246.     /* The overflow test done here in SETL version is done above after
  1247.      * calls to arith routines in C version 
  1248.      */
  1249.  
  1250.     if (op_type == symbol_integer || op_type == symbol_float
  1251.       || op_type == symbol_dfixed || op_type == symbol_character
  1252.       || NATURE(op_type) == na_enum) {
  1253.         /*    Predefined types: value is already known to be in range.*/
  1254.         return op1_val;
  1255.     }
  1256.     else {
  1257.         /* At this point everything is known to be constant.
  1258.          * If the constraint is obeyed, return the value without
  1259.          * a range qualification. Otherwise emit a constraint
  1260.          * exception.
  1261.          */
  1262.  
  1263.         /* c_error =     ( root_type(op_type) != symbol_dfixed ?
  1264.          * (op1_val < lo_val) || (op1_val > hi_val)
  1265.          */
  1266.         if (is_fixed_type(root_type(op_type))) {
  1267.             if (op1_val->const_kind == CONST_RAT) {
  1268.                 const_check(op1_val, CONST_RAT);
  1269.                 const_check(lo_val, CONST_RAT);
  1270.                 const_check(hi_val, CONST_RAT);
  1271.                 c_error = (rat_lss(RATV(op1_val), RATV(lo_val))
  1272.                   || rat_gtr(RATV(op1_val), RATV(hi_val)));
  1273.             }
  1274.             else if (op1_val->const_kind == CONST_REAL) {
  1275.                 rop1_val = rat_frr(REALV(op1_val));
  1276.                 const_check(lo_val, CONST_RAT);
  1277.                 const_check(hi_val, CONST_RAT);
  1278.                 c_error = (rat_lss(rop1_val, RATV(lo_val))
  1279.                   || rat_gtr(rop1_val, RATV(hi_val)));
  1280.             }
  1281.         }
  1282.         else if (op1_val->const_kind == CONST_INT) {
  1283.             const_check(op1_val, CONST_INT);
  1284.             const_check(lo_val, CONST_INT);
  1285.             const_check(hi_val, CONST_INT);
  1286.             c_error = (INTV(op1_val) < INTV(lo_val))
  1287.               || (INTV(op1_val) > INTV(hi_val));
  1288.         }
  1289.         else if (op1_val->const_kind == CONST_REAL) {
  1290.             const_check(op1_val, CONST_REAL);
  1291.             const_check(lo_val, CONST_REAL);
  1292.             const_check(hi_val, CONST_REAL);
  1293.             c_error = (REALV(op1_val) < REALV(lo_val))
  1294.               || (REALV(op1_val) > REALV(hi_val));
  1295.         }
  1296.         if (c_error) {
  1297.             return const_new(CONST_CONSTRAINT_ERROR);
  1298.         }
  1299.         else {
  1300.             return op1_val;
  1301.         }
  1302.     }
  1303. }
  1304.  
  1305. static Const eval_real_type_attribute(Node node)  /*;eval_real_type_attribute*/
  1306. {
  1307.     /*
  1308.      *    Static evaluation of real types characteristics
  1309.      *    ===============================================
  1310.      */
  1311.  
  1312.     Node    attr_node, arg_node, lo, hi, precision;
  1313.     Const    result, precision_const;
  1314.     Tuple    sig;
  1315.     int        kind, attrkind, static_bounds;
  1316.     int        fl_digits;
  1317.     Rational    delta, fx_low, fx_high, xdelta, small;
  1318.     /* the following are macros in SETL, and should eventually be converted */
  1319.  
  1320. #define rat_1 rat_fri(int_fri(1), int_fri(1))
  1321. #define rat_2 rat_fri(int_fri(2), int_fri(1))
  1322.  
  1323.     if (cdebug2 > 3) TO_ERRFILE("AT PROC : eval_real_type_attribute");
  1324.  
  1325.     attr_node = N_AST1(node);
  1326.     arg_node = N_AST2(node);
  1327.     result = const_new(CONST_OM);
  1328.     sig = SIGNATURE(N_UNQ(arg_node));
  1329.     kind = (int) sig[1];
  1330.     /*
  1331.      *    Part A : FLOATING POINT REAL
  1332.      *
  1333.      *    For a floating point real type FL, we have the following
  1334.      *    basic informations:
  1335.      *      digits  (SETL_integer)
  1336.      *      fl_high (SETL_real)
  1337.      *      fl_low  (SETL_real)
  1338.      */
  1339.  
  1340.     if (kind == CONSTRAINT_DIGITS) {
  1341.         lo = (Node) sig[2];
  1342.         hi = (Node) sig[3];
  1343.         precision = (Node) sig[4];
  1344.         precision_const = (Const) N_VAL(precision);
  1345.         const_check(precision_const, CONST_INT);
  1346.         fl_digits = INTV(precision_const);
  1347.         attrkind = (int) attribute_kind(node);
  1348.         /*
  1349.          *
  1350.          *     FL'DIGITS    --> universal_integer
  1351.          *
  1352.          *          The minimum number of significant decimal digits.
  1353.          */
  1354.         if (attrkind == ATTR_DIGITS) {
  1355.             result = uint_const(int_fri(fl_digits));
  1356.         }
  1357.         /*
  1358.          *
  1359.          *     FL'MANTISSA  --> universal_integer
  1360.          *
  1361.          *          The minimum number of binary digits required for DIGITS:
  1362.          *            ceil(fl_digits*log(10)/log(2))+1)
  1363.          *
  1364.          */
  1365.  
  1366.         else if (attrkind == ATTR_MANTISSA) {
  1367.             result = uint_const(fl_mantissa(fl_digits));
  1368.         }
  1369.         /*
  1370.          *     FL'EPSILON   --> universal_real
  1371.          *
  1372.          *          The absolute value of the difference between the nuber 1.0
  1373.          *          and the next model number above :
  1374.          *            = 2.0**(1-FL'MANTISSA)
  1375.          */
  1376.         else if (attrkind == ATTR_EPSILON) {
  1377.             result = rat_const(rat_exp(rat_2, int_sub(int_fri(1),
  1378.               fl_mantissa(fl_digits))));
  1379.         }
  1380.         /*
  1381.          *     FL'EMAX      --> universal_integer
  1382.          *
  1383.          *          The largest exponent value in binary canonical form:
  1384.          *            = 4*FL'MANTISSA
  1385.          */
  1386.         else if (attrkind == ATTR_EMAX || attrkind == ATTR_SAFE_EMAX) {
  1387.             result = uint_const(fl_emax(fl_digits));
  1388.         }
  1389.         /*
  1390.          *     FL'SMALL     --> universal_real
  1391.          *
  1392.          *          The smallest positive non-zero number :
  1393.          *            = 2.0**(- FL'EMAX -1)
  1394.          */
  1395.         else if (attrkind == ATTR_SMALL || attrkind == ATTR_SAFE_SMALL) {
  1396.             result = rat_const( rat_exp(rat_2, 
  1397.               int_umin(int_add(fl_emax(fl_digits), int_fri(1)))));
  1398.         }
  1399.         /*
  1400.          *     FL'LARGE     --> universal_integer
  1401.          *
  1402.          *           The largest positive number:
  1403.          *             = 2.0**FL'EMAX * (1.0 - 2.0**(-FL'MANTISSA))
  1404.          */
  1405.         else if (attrkind == ATTR_LARGE || attrkind == ATTR_SAFE_LARGE) {
  1406.             /* TBSL: check types, this looks wrong */
  1407.             result = rat_const(rat_mul( rat_exp(rat_2, fl_emax(fl_digits)),
  1408.               rat_sub(rat_1, rat_exp(rat_2,int_umin(fl_mantissa(fl_digits))))));
  1409.         }
  1410.         /*
  1411.          *     FL'SAFE_EMAX =  FL'BASE'EMAX
  1412.          *     FL'SAFE_SMALL =  FL'BASE'SMALL
  1413.          *     FL'SAFE_LARGE =  FL'BASE'LARGE
  1414.          *
  1415.          *      cf. FL'EMAX, FL'SMALL, FL'LARGE
  1416.          */
  1417.  
  1418.         /*
  1419.          *     FL'MACHINE_ROUNDS --> boolean
  1420.          */
  1421.         else if (attrkind == ATTR_MACHINE_ROUNDS) {
  1422.             result = test_expr(FALSE);
  1423.         }
  1424.         /*
  1425.          *     FL'MACHINE_OVERFLOWS --> boolean
  1426.          */
  1427.         else if (attrkind == ATTR_MACHINE_OVERFLOWS) {
  1428.             result = test_expr(TRUE);
  1429.         }
  1430.         /*
  1431.          *     FL'MACHINE_RADIX     --> universal_integer
  1432.          */
  1433.         else if (attrkind == ATTR_MACHINE_RADIX) {
  1434.             result = uint_const(int_fri(2));
  1435.         }
  1436.  
  1437.         /*
  1438.          *     FL'MACHINE_MANTISSA  --> universal_integer
  1439.          */
  1440.         else if (attrkind == ATTR_MACHINE_MANTISSA) {
  1441.             result = uint_const(int_fri(24));
  1442.         }
  1443.         /*
  1444.          *     FL'MACHINE_EMAX      --> universal_integer
  1445.          */
  1446.         else if (attrkind == ATTR_MACHINE_EMAX) {
  1447.             result = uint_const(int_fri(127));
  1448.         }
  1449.         /*
  1450.          *     FL'MACHINE_EMIN      --> universal_integer
  1451.          */
  1452.         /* We have to modified MACHINE_EMIN so that test c45524a de C4dep */
  1453.         /* passes */
  1454.         else if (attrkind == ATTR_MACHINE_EMIN) {
  1455.             result = uint_const(int_fri(-127));
  1456.         }
  1457.     }
  1458.     /*
  1459.      *    Part B : FIXED POINT REAL
  1460.      *
  1461.      *    For a fixed point real type FX, we have the following basic
  1462.      *    informations:
  1463.      *     delta      (universal_real)
  1464.      *     fx_low      (universal_real)
  1465.      *     fx_high  (universal_real)
  1466.      *    but the bounds may not be static...
  1467.      */
  1468.     else if (kind == CONSTRAINT_DELTA) {
  1469.         attrkind = (int) attribute_kind(node);
  1470.         if (attrkind == ATTR_SAFE_LARGE || attrkind == ATTR_SAFE_SMALL)
  1471.             sig = SIGNATURE(base_type(N_UNQ(arg_node)));
  1472.         lo = (Node) sig[2];
  1473.         hi = (Node) sig[3];
  1474.         precision = (Node) sig[4];
  1475.         static_bounds = (is_static_expr(lo) && is_static_expr(hi));
  1476.         delta = RATV((Const) N_VAL(precision));
  1477.         small = RATV((Const)N_VAL((Node)numeric_constraint_small(sig)));
  1478.         if (static_bounds) {
  1479.             eval_static(lo);
  1480.             eval_static(hi);
  1481.             const_check((Const)N_VAL(lo), CONST_RAT);
  1482.             const_check((Const)N_VAL(hi), CONST_RAT);
  1483.             fx_low = RATV((Const)N_VAL(lo));
  1484.             fx_high = RATV((Const) N_VAL(hi));
  1485.         }
  1486.         /*
  1487.          *     FX'DELTA     --> universal_real
  1488.          *
  1489.          *          The absolute value of the error bound.
  1490.          */
  1491.         if (attrkind == ATTR_DELTA) {
  1492.             result = rat_const(delta);
  1493.         }
  1494.         /*
  1495.          *     FX'SMALL     --> universal_real
  1496.          *
  1497.          *          The largest power of 2 not greater than the delta:
  1498.          *         = 2.0**floor(log(delta)/log(2.0))
  1499.          */
  1500.         else if (attrkind == ATTR_SMALL || attrkind == ATTR_SAFE_SMALL) {
  1501.             result = rat_const(small);
  1502.         }
  1503.         /*
  1504.          *     FX'MANTISSA  --> universal_integer
  1505.          *
  1506.          *         The number of binary digits required:
  1507.          *        = ceil(log(max(abs(fx_high), abs(fx_low))/FX'SMALL)/log(2.0)))
  1508.          */
  1509.  
  1510.         else if (attrkind == ATTR_MANTISSA) {
  1511.             if (static_bounds) {
  1512.                 result=uint_const(int_fri(fx_mantissa(fx_high, fx_low, small)));
  1513.             }
  1514.         }
  1515.         /*
  1516.          *     FX'LARGE     --> universal_real
  1517.          *
  1518.          *          The largest positive number :
  1519.          *         = (2.0**FX'MANTISSA - 1) * FX'SMALL
  1520.          */
  1521.         else if (attrkind == ATTR_LARGE || attrkind == ATTR_SAFE_LARGE) {
  1522.             if (static_bounds) {
  1523.                 result = rat_const(rat_mul( rat_sub(rat_exp(rat_2,
  1524.                   int_fri( fx_mantissa(fx_high, fx_low, small))), rat_1),
  1525.                   small));
  1526.             }
  1527.         }
  1528.         /*
  1529.          *     FX'FORE      --> universal_integer
  1530.          *
  1531.          *          The minimum number of characters needed for the integer
  1532.          *          part of the decimal representation (including sign).
  1533.          */
  1534.         else if (attrkind == ATTR_FORE) {
  1535.             if (static_bounds) {
  1536.                 int *ivalue_10, *rat_n, *rat_d; /* Multi-precision numbers */
  1537.                 int ivalue_n;
  1538.                 Rational fx_maximum;
  1539.  
  1540.                 ivalue_10 = int_fri(10);
  1541.                 ivalue_n = 2;
  1542.                 fx_maximum = fx_max(fx_high, fx_low);
  1543.                 rat_n = num(rat_abs(fx_maximum));
  1544.                 rat_d = den(rat_abs(fx_maximum));
  1545.                 while (int_geq(int_quo(rat_n, rat_d), ivalue_10)) {
  1546.                     rat_d = int_mul(rat_d, ivalue_10);
  1547.                     ivalue_n += 1;
  1548.                 }
  1549.                 result = uint_const(int_fri(ivalue_n));
  1550.             }
  1551.         }
  1552.         /*
  1553.          *     FX'AFT          --> universal_integer
  1554.          *
  1555.          *          The number of decimal digits needed after the decimal point
  1556.          *        = smallest n such that (10**N)*FX'DELTA >= 1.0
  1557.          */
  1558.         else if (attrkind == ATTR_AFT) {
  1559.             xdelta = delta;
  1560.             result = uint_const(int_fri(1));
  1561.             while (rat_lss(xdelta, rat_fri(int_fri(1), int_fri(10)))) {
  1562.                 xdelta = rat_mul(xdelta, rat_fri(int_fri(10), int_fri(1)));
  1563.                 UINTV(result)= int_add(UINTV(result), int_fri(1));
  1564.             }
  1565.         }
  1566.         /*
  1567.          *     FX'SAFE_SMALL =  FX'BASE'SMALL
  1568.          *     FX'SAFE_LARGE =  FX'BASE'LARGE
  1569.          *
  1570.          *     cf. FX'SMALL and FX'LARGE
  1571.          */
  1572.  
  1573.         /*
  1574.          *     FX'MACHINE_ROUNDS --> boolean
  1575.          */
  1576.         else if (attrkind == ATTR_MACHINE_ROUNDS) {
  1577.             result = test_expr(TRUE);
  1578.         }
  1579.         /*
  1580.          *     FX'MACHINE_OVERFLOWS --> boolean
  1581.          */
  1582.         else if (attrkind == ATTR_MACHINE_OVERFLOWS) {
  1583.             result = test_expr(TRUE);
  1584.         }
  1585.     }
  1586.     return result;
  1587. }
  1588.  
  1589. static Const check_overflow(Node node, Const x)                /*check_overflow*/
  1590. {
  1591.     /*
  1592.      * Check_overflow tests its argument against ADA_MAX_INTEGER or
  1593.      * ADA_MAX_REAL, returning the setl value of the argument or the
  1594.      * raise NUMERIC_ERROR instruction.  Universal integers and reals are
  1595.      * converted to setl values.
  1596.      */
  1597.  
  1598.     int    attrkind;
  1599.     Const    result;
  1600.  
  1601.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  check_overflow");
  1602.  
  1603.     return const_new(CONST_OM); /*TBSL: for initial chceckout */
  1604. #ifdef TBSL
  1605.     if (!is_numeric(N_TYPE(node))
  1606.         return;
  1607.     else if (x == symbol_overflow) {
  1608.         create_raise(node, symbol_constraint_error);
  1609.         result = om;
  1610.     }
  1611.     else
  1612.         attrkind = (int) attribute_kind(node); /*TBSL - check this  ds 14 nov */
  1613.     case(type(x)) {
  1614.             if (streq(attr, "INTEGER")) {
  1615.                 /*if (abs(x) > ADA_MAX_INTEGER) { 
  1616.              This previous test was wrong due to disymetry */
  1617.                 if ((x> ADA_MAX_INTEGER) || (x < ADA_MIN_INTEGER)) {
  1618.                     create_raise(node, symbol_constraint_error);
  1619.                         result = om;
  1620.                 }
  1621.                 else
  1622.                     result = x;
  1623.             }
  1624.             else if (streq(attr, "REAL")) {
  1625.                 if (abs(x) > ADA_MAX_REAL) {
  1626.                     create_raise(node, symbol_constraint_error);
  1627.                         result = om;
  1628.                 }
  1629.                 else
  1630.                     result = x;
  1631.             }
  1632.             else if (streq(attr, "TUPLE")) {
  1633.                 if is_universal_integer(x) {
  1634.                     if ((res = int_toi(x)) == 'OVERFLOW') {
  1635.                         create_raise(node, symbol_constraint_error);
  1636.                             result = om;
  1637.                     }
  1638.                     else
  1639.                         result = res;
  1640.                 }
  1641.                 else
  1642.                     if ((res = rat_tor(x, ada_real_digits)) == 'OVERFLOW') {
  1643.                         create_raise(node, symbol_constraint_error);
  1644.                             result = om;
  1645.                     }
  1646.                     else
  1647.                         result = res;
  1648.         else
  1649.             ;        /* Not a numeric node */
  1650.             }
  1651.             return result;
  1652. #endif
  1653.  
  1654. }
  1655.  
  1656. static int  *fl_mantissa(int fl_digits)                        /*;fl_mantissa*/
  1657. {
  1658.     /*
  1659.      *            ceil(fl_digits*log(10)/log(2))+1)
  1660.      */
  1661.     return (int_fri((int)ceil(((double)fl_digits*log(10.0))/log(2.0) + 1.0)));
  1662. }
  1663.  
  1664. static int *fl_emax(int fl_digits)                            /*;fl_emax*/
  1665. {
  1666.     return    int_mul(int_fri(4), fl_mantissa(fl_digits));
  1667. }
  1668.  
  1669. int is_universal_integer(Const x)                /*;is_universal_integer*/
  1670. {
  1671.     return is_const_uint(x);
  1672. }
  1673.  
  1674. int is_universal_real(Const x)                        /*;is_universal_real*/
  1675. {
  1676.     return  is_const_rat(x);
  1677. }
  1678.  
  1679. static void insert_and_prune(Node node, Const value)    /*;insert_and_prune*/
  1680. {
  1681.     /* When an expression tree can be constant-folded, it is reduced to a
  1682.      * formattd value for the interpreter, and its descendants are dis-
  1683.      * carded. The type has been established during type resolution.
  1684.      */
  1685.     int nk;
  1686.     Span savespan;
  1687.  
  1688.     if (cdebug2 > 3) { }
  1689.  
  1690.     nk = N_KIND(node);
  1691.  
  1692.     savespan = get_left_span(node);
  1693.     if (N_AST1_DEFINED(nk)) N_AST1(node) = (Node) 0;
  1694.     if (N_AST4_DEFINED(nk)) N_AST4(node) = (Node) 0;
  1695.     N_KIND(node) = as_ivalue;
  1696.     N_UNQ(node) = (Symbol) 0; /* as_ivalue has no n_unq */
  1697.     N_VAL(node) = (char *) value;
  1698.     N_SPAN0(node) = savespan->line;
  1699.     N_SPAN1(node) = savespan->col;
  1700. }
  1701.  
  1702. void create_raise(Node node, Symbol exception)                /*;create_raise*/
  1703. {
  1704.     /* This routine replaces the subtree at node by a -raise- operator
  1705.      * with -exception- as its operand
  1706.      */
  1707.     Node    excp_node;
  1708.     Node    span_node;
  1709.  
  1710.     if (cdebug2 > 3) TO_ERRFILE("AT PROC :  create_raise");
  1711.  
  1712.     warning(strjoin("Evaluation of expression will raise ",
  1713.       ORIG_NAME(exception)), node);
  1714.  
  1715.     excp_node = node_new(as_simple_name);
  1716.     span_node = node_new(as_simple_name);
  1717.     copy_span(node, excp_node);
  1718.     copy_span(node, span_node);
  1719.     N_UNQ(excp_node) = exception;
  1720.     N_KIND(node) = as_raise;
  1721.     N_AST1(node) = excp_node;
  1722.     N_AST2(node) = span_node;
  1723.     N_TYPE(node) = (Symbol)0;
  1724.  
  1725.     return;
  1726. }
  1727.  
  1728. static Rational fx_max (Rational fx_high, Rational fx_low)            /*;fx_max*/
  1729. {
  1730.     if (rat_geq(rat_abs(fx_high), rat_abs(fx_low)))
  1731.         return rat_abs(fx_high);
  1732.     else 
  1733.         return rat_abs(fx_low);
  1734. }
  1735.  
  1736. static Const test_expr(int e)                                /*;test_expr*/
  1737. {
  1738.     Const    res;
  1739.  
  1740.     res = const_new(CONST_INT);
  1741.     INTV(res) = e;
  1742.     return res;
  1743. }
  1744.